home *** CD-ROM | disk | FTP | other *** search
/ Software Vault: The Gold Collection / Software Vault - The Gold Collection (American Databankers) (1993).ISO / cdr51 / lib201.zip / DATES.PRG < prev    next >
Text File  |  1993-04-02  |  66KB  |  1,582 lines
  1. *-------------------------------------------------------------------------------
  2. *-- Program...: DATES.PRG
  3. *-- Programmer: Ken Mayer (CIS: 71333,1033)
  4. *-- Date......: 02/24/1993
  5. *-- Notes.....: These are the date functions/procedures I felt were not as
  6. *--             commonly used as those left behind in PROC.PRG. See README.TXT
  7. *--             for details on the use of this library file.
  8. *-------------------------------------------------------------------------------
  9.  
  10. FUNCTION DateText3
  11. *-------------------------------------------------------------------------------
  12. *-- Programmer..: Miriam Liskin
  13. *-- Date........: 03/02/1992
  14. *-- Notes.......: Display date in format  Month, year
  15. *-- Written for.: dBASE IV, 1.1
  16. *-- Rev. History: 05/21/1991 - original function.
  17. *--               03/02/1992 - This one's Douglas P. Saine's (XRED) invention.
  18. *--               In his words: "I just removed the middle part looking for
  19. *--               the day. For the things I do, I only need the month and
  20. *--               year. (I work for a defense contracter, accuracy of dates
  21. *--               has never been of great concern. <G>)"
  22. *-- Calls.......: None
  23. *-- Called by...: Any
  24. *-- Usage.......: DateText3(<dDate>)
  25. *-- Example.....: ? DateText3(date())
  26. *-- Returns.....: July, 1991
  27. *-- Parameters..: dDate = date to be converted
  28. *-------------------------------------------------------------------------------
  29.  
  30.     parameters dDate
  31.     
  32. RETURN cmonth(dDate)+", "+str(year(dDate),4)
  33. *-- EoF: DateText3()
  34.  
  35. FUNCTION Age2
  36. *-------------------------------------------------------------------------------
  37. *-- Programmer..: Martin Leon (HMAN)
  38. *-- Date........: 04/22/1992
  39. *-- Notes.......: Returns number of full years between two dates, which is
  40. *--               age of a person born on the first date as of the second.
  41. *-- Written for.: dBASE IV, 1.1
  42. *-- Rev. History: 10/23/1991 - original function.
  43. *--               04/22/1992 -- Description modified, parameters changed by
  44. *--               Jay Parsons (CIS: 70160,340).
  45. *-- Calls.......: None
  46. *-- Called by...: Any
  47. *-- Usage.......: Age2(<d1>,<d2>)
  48. *-- Example.....: ? "Joe was "+ltrim(str(age2(dBDay,{10/16/85})))+;
  49. *--                        " on the day of ..."
  50. *-- Returns.....: Numeric value in years
  51. *-- Parameters..: d1 = first date, such as date of birth
  52. *--               d2 = second date, when age is wanted
  53. *-------------------------------------------------------------------------------
  54.  
  55.     parameters d1, d2
  56.     private nYears
  57.     
  58.     nYears = year(d2) - year(d1)
  59.     do case
  60.         case month(d1) > month(d2)
  61.             nYears = nYears - 1
  62.         case month(d1) = month(d2)
  63.             if day(d1) > day(d2)
  64.                 nYears = nYears - 1
  65.             endif
  66.     endcase
  67.  
  68. RETURN nYears
  69. *-- EoF: Age2()
  70.  
  71. FUNCTION IsLeap
  72. *-------------------------------------------------------------------------------
  73. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  74. *-- Date........: 01/13/1992
  75. *-- Notes.......: Is the year given a Leap Year? Year given must be after 1500
  76. *-- Written for.: dBASE IV, 1.1
  77. *-- Rev. History: 11/08/1991 - original function.
  78. *--               01/13/1992 -- updated to handle two digit OR four digit year.
  79. *-- Calls.......: None
  80. *-- Called by...: Any
  81. *-- Usage.......: IsLeap(<nYear>)
  82. *-- Example.....: IsLeap(91)
  83. *-- Returns.....: Logical (.t./.f.) 
  84. *-- Parameters..: nYear  = Numeric form of year -- last two digits (i.e., 91),
  85. *--                        or all four digits (i.e., 1991)
  86. *-------------------------------------------------------------------------------
  87.     
  88.     parameter nYear
  89.     private lReturn
  90.     
  91.     *-- deal with two digit year ...
  92.     if nYear < 100
  93.         nYear = nYear + 100 * int(year(date())/100)
  94.     endif
  95.     
  96.     lReturn = mod(iif(mod(nYear,100)=0,nYear/100,nYear),4)=0
  97.     
  98. RETURN lReturn
  99. *-- EoF: IsLeap()
  100.  
  101. FUNCTION Annivrsry
  102. *-------------------------------------------------------------------------------
  103. *-- Programmer..: David Love (CIS: 70153,2433) and Jay Parsons (CIS: 70160,340)
  104. *-- Date........: 11/10/1991
  105. *-- Notes.......: Checks to see if an anniversary date falls within a range of
  106. *--               dates (handy for mailings for organizations, checking to see
  107. *--               if someone's birthday falls within certain dates, etc.
  108. *-- Written for.: dBASE IV, 1.1
  109. *-- Rev. History: 11/10/1991 -- Original Release
  110. *-- Calls.......: AGE2()               Function in DATES.PRG
  111. *-- Called by...: Any
  112. *-- Usage.......: Annivrsry(<dTest>,<dBegin>,<dEnd>)
  113. *-- Example.....: if Annivrsry(dBDay,{03/01/91},{03/31/91})
  114. *--                  *-- do something
  115. *--               endif
  116. *-- Returns.....: .t. if a date (dTest) falls within the period beginning at
  117. *--               dBegin or ending at dEnd, inclusive. .F. for any other
  118. *--               occurance, including invalid ranges or blank dates.
  119. *-- Parameters..: dTest  = Date being tested for ...
  120. *--               dBegin = Beginning of range
  121. *--               dEnd   = End of range
  122. *-------------------------------------------------------------------------------
  123.  
  124.     parameters dTest, dBegin, dEnd
  125.     private nYears
  126.     
  127.     nYears = 0
  128.     if dBegin <= dEnd .AND. dTest <= dEnd        && will be false if blank
  129.       nYears = age2(dTest,dEnd) - iif(dTest < dBegin,age2(dTest,dBegin-1),0)
  130.     endif
  131.  
  132. RETURN nYears > 0
  133. *-- EoF: Annivrsry()
  134.  
  135. FUNCTION AddMonths
  136. *-------------------------------------------------------------------------------
  137. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  138. *-- Date........: 11/10/1991
  139. *-- Notes.......: Finds same day as given date N months ahead. 
  140. *--               This function will return the first day of the following
  141. *--               month if there is no date in the month otherwise returned 
  142. *--               and nMonths is positive, or the last day of the month if 
  143. *--               nMonths is negative.  That is, a call with {01/31/91} 
  144. *--               (January 31, 1991) and 1 would yield March 1, there being 
  145. *--               no February 31.
  146. *--                 Do not use this function successively to find first the
  147. *--               date one month ahead, then the date one month beyond that.  
  148. *--               Instead, to find the date two months ahead from the original 
  149. *--               date, call this function with the original date and 
  150. *--               nMonths = 2.  Otherwise, in the example, you'll get April 1 
  151. *--               the second time rather than the correct March 31.
  152. *-- Written for.: dBASE IV, 1.1
  153. *-- Rev. History: 11/10/1991 -- Original Release
  154. *-- Calls.......: None
  155. *-- Called by...: Any
  156. *-- Usage.......: AddMonths(<dDate>,<nMonths>)
  157. *-- Example.....: ?AddMonths({01/01/91},1)
  158. *-- Returns.....: Date
  159. *-- Parameters..: dDate   = Date being tested for ...
  160. *--               dMonths = Number of months "ahead"
  161. *-------------------------------------------------------------------------------
  162.     
  163.     parameters dDate, nMonths
  164.     private dNew, dTest,dReturn
  165.     
  166.     dNew = dDate - day(dDate)+ 15 + 30.436875 * nMonths  && middle of month
  167.     dTest = dNew - day(dNew) + day(dDate)
  168.     dReturn = iif(month(dTest) = month(dNew),dTest, ;
  169.            dTest - day(dTest) + iif(nMonths > 0, 1, 0))
  170.  
  171. RETURN dReturn
  172. *-- EoF: AddMonths()
  173.  
  174. FUNCTION AddYears
  175. *-------------------------------------------------------------------------------
  176. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  177. *-- Date........: 11/14/1991
  178. *-- Notes.......: Finds same day as given date N years ahead. 
  179. *--               Using this function dBASE IV will take care of converting 
  180. *--               February 29 to March 1 if moving from a leap to a non-leap
  181. *--               year.  However, neither may be used backwards (negative 
  182. *--               value of nYears) since the date a year before February 29,
  183. *--               1992 will be returned as March 1, 1991, not February 28, 1991.
  184. *--               If you must move back, either check explicitly for February 29
  185. *--               as the original date or add code as in the addmonths()
  186. *--               function to test for the date returned being of a different
  187. *--               month than the original and, if it is, to subtract its day().
  188. *-- Written for.: dBASE IV, 1.1
  189. *-- Rev. History: 11/10/1991 - original function.
  190. *--               11/14/1991 - Ken Mayer - expanded out to make it easier
  191. *--                            to read, and see what's happening.
  192. *-- Calls.......: None
  193. *-- Called by...: Any
  194. *-- Usage.......: AddYears(<dDate>,<nYears>)
  195. *-- Example.....: ?AddYears({01/01/91},1)
  196. *-- Returns.....: Date
  197. *-- Parameters..: dDate  = Date being tested for ...
  198. *--               dYears = Number of Years "ahead"
  199. *-------------------------------------------------------------------------------
  200.     
  201.     parameters dDate, nYears
  202.     private cYear,cMonth,cDay,dReturn
  203.     
  204.     cYear = str(year(dDate) + nYears)
  205.     cMonth = right(str(month(dDate) + 100),2)
  206.     cDay = right(str(day(dDate) + 100),2)
  207.     dReturn = ctod(cMonth+"/"+cDay+"/"+cYear)
  208.         
  209. RETURN dReturn
  210. *-- EoF: AddYears()
  211.  
  212. FUNCTION DoY
  213. *-------------------------------------------------------------------------------
  214. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  215. *-- Date........: 11/14/1991
  216. *-- Notes.......: Returns the day of the year of a date (from beginning of the
  217. *--               year).
  218. *-- Written for.: dBASE IV, 1.1
  219. *-- Rev. History: 11/10/1991 - original function.
  220. *--               11/14/1991 - Ken Mayer - expanded for readability ...
  221. *-- Calls.......: None
  222. *-- Called by...: Any
  223. *-- Usage.......: DoY(<dDate>)
  224. *-- Example.....: ?DoY({01/01/91})
  225. *-- Returns.....: Numeric value of day of year
  226. *-- Parameters..: dDate  = Date being tested for ...
  227. *-------------------------------------------------------------------------------
  228.  
  229.     parameters dDate
  230.     private cYear,dStart,nReturn
  231.     
  232.     cYear = right(str(year(dDate)),2)
  233.     dStart = ctod("01/01/"+cYear)
  234.     nReturn = dDate+1 - dStart
  235.     
  236. RETURN nReturn
  237. *-- EoF: DoY()
  238.  
  239. FUNCTION WeekNo
  240. *-------------------------------------------------------------------------------
  241. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  242. *-- Date........: 11/14/1991
  243. *-- Notes.......: Returns the week number of the year of a date (from beginning 
  244. *--               of the year).
  245. *--               To use this function but start the week on a different day,
  246. *--               change the 1 in the second-to-last line, the dow() of Sunday, 
  247. *--               to the dow() of the day that should start each week, 2 for 
  248. *--               Monday through 7 for Saturday.
  249. *-- Written for.: dBASE IV, 1.1
  250. *-- Rev. History: 11/10/1991 - original function.
  251. *--               11/14/91 - Ken Mayer - expanded for readability ...
  252. *-- Calls.......: DoY()                Function in DATES.PRG
  253. *-- Called by...: Any
  254. *-- Usage.......: WeekNo(<dDate>)
  255. *-- Example.....: ?WeekNo({01/01/91})
  256. *-- Returns.....: Numeric value of week number
  257. *-- Parameters..: dDate  = Date being tested for ...
  258. *-------------------------------------------------------------------------------
  259.     
  260.     parameters dDate
  261.     private dBaseDate,nReturn
  262.     
  263.     dBaseDate = dDate - doy(dDate)
  264.     dBaseDate = dBaseDate - mod(dow(dBaseDate - 1), 7)
  265.     nReturn = int((dDate - dBaseDate) / 7)
  266.  
  267. RETURN nReturn
  268. *-- EoF: WeekNo()
  269.  
  270. FUNCTION Holiday
  271. *-------------------------------------------------------------------------------
  272. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  273. *-- Date........: 04/22/1992
  274. *-- Notes.......: Returns the date of a specific "floating" holiday (using 
  275. *--               chart below) for current year. 
  276. *--               Name                 Code
  277. *--               President's Day      P
  278. *--               Daylight saving time D
  279. *--               Memorial Day         M
  280. *--               Labor Day            L
  281. *--               Columbus Day         C
  282. *--               Resume Standard time S
  283. *--               Election Day         E
  284. *--               Thanksgiving         T
  285. *--               Advent (1st Sunday)  A
  286. *-- Written for.: dBASE IV, 1.1
  287. *-- Rev. History: 11/01/1991 - original function.
  288. *--               11/15/1991 - Ken Mayer - takes a code and year -- I basically
  289. *--               simplified the use of the function.
  290. *--               04/22/1992 - Jay Parsons - added 'D' and 'S' options
  291. *--               (daylight saving time and return to standard)
  292. *-- Calls.......: None
  293. *-- Called by...: Any
  294. *-- Usage.......: Holiday(<nYear>,"<cCode>")
  295. *-- Example.....: ? Holiday(92,"P")   && date of President's day, 1992
  296. *-- Returns.....: Date of specified holiday ...
  297. *-- Parameters..: nYear = Year you need the holiday date for ...
  298. *--               cCode = one of the codes above for specific holiday
  299. *-------------------------------------------------------------------------------
  300.  
  301.     parameters nYear,cCode
  302.     private dBaseDate,cCode,cYear,nDoW,cFirst,dReturn
  303.     
  304.     cCode = upper(cCode)
  305.     cYear = ltrim(str(nYear))
  306.     do case
  307.                 case cCode = "P"    && President's day (3rd Mon of Feb)
  308.             cFirst = "02/15/"
  309.             nDoW   = 2
  310.         case cCode = "D"    && Daylight time U.S. (1st Sun of April)
  311.             cFirst = "04/01/"
  312.             nDoW   = 1
  313.                 case cCode = "M"    && Memorial day  (last Mon of May)
  314.                         cFirst = "05/25/"
  315.             nDoW   = 2
  316.         case cCode = "L"    && Labor day  (1st Mon of Sep)
  317.                         cFirst = "09/01/"
  318.             nDoW   = 2
  319.         case cCode = "C"    && Columbus Day  (2nd Mon of Oct)
  320.                         cFirst = "10/08/"
  321.             nDoW   = 2
  322.                 case cCode = "S"    && Standard Time U.S. (Last Sun of Oct)
  323.             cFirst = "10/25/"
  324.             nDoW = 1
  325.         case cCode = "E"    && Election Day  (1st Tues of Nov not Nov 1)
  326.                         cFirst = "11/02/"
  327.             nDoW   = 3
  328.         case cCode = "T"    && Thanksgiving (fourth Thursday of Nov)
  329.                         cFirst = "11/22/"
  330.             nDoW   = 5
  331.         case cCode = "A"    && 1st Sun of Advent (Sunday closest Nov 30)
  332.                         cFirst = "11/27/"
  333.             nDoW   = 1
  334.         otherwise
  335.             return {}        && if not one of above, return blank date ...
  336.     endcase
  337.     dFirst = ctod(cFirst + cYear)
  338.         dBaseDate = dFirst + 7 - nDow
  339.         dReturn = dBaseDate - dow( dBaseDate ) + nDow    && dow( dBaseDate )
  340.     
  341. RETURN dReturn
  342. *-- EoF: Holiday()
  343.  
  344. FUNCTION EasterDay
  345. *-------------------------------------------------------------------------------
  346. *-- Programmer..: Jay Parsons (USSBBS, CIS 70160,340)
  347. *-- Date........: 12/03/1992
  348. *-- Notes.......: Returns date of Easter for given year after 1582.
  349. *--               This gives the date of Easter as celebrated by Western
  350. *--               churches.  The algorithm is from Example 1.3.2.14 of
  351. *--               Volume I of "The Art of Computer Programming", 2nd
  352. *--               Edition, Addison-Wesley, Reading, MA, 1973, by Donald
  353. *--               Knuth, who attributes it to Aloysius Lilius of Naples
  354. *--               and Christopher Clavius of Germany, both floruit 1582.
  355. *-- Written for.: dBASE IV, 1.1
  356. *-- Rev. History: 11/18/1991 - original function.
  357. *--               04/22/1992 - Jay Parsons - Notes expanded.
  358. *--               11/20/1992 - David Love - Added the private variable lYear
  359. *--               12/03/1992 - Jay Parsons - renamed lYear to nYr, dPascMoon
  360. *-- Calls.......: None
  361. *-- Called by...: Any
  362. *-- Usage.......: EasterDay(<Year>)
  363. *-- Example.....: EasterDay(91)
  364. *-- Returns.....: Date (in dBASE date format) of Easter
  365. *-- Parameters..: nYear  =  Numeric form of year - YYYY or YY format
  366. *-------------------------------------------------------------------------------
  367.     
  368.     parameters nYear
  369.     private nYr,nGolden,nCentury,nNoLeap,nMoonOrbit,nEPact,dPascMoon,dReturn
  370.     
  371.     *-- deal with two digit year ...
  372.     nYr = nYear
  373.     if nYr < 100
  374.         nYr = nYr + 100 * int(year(date())/100)
  375.     endif
  376.     
  377.     nGolden     = 1+mod(nYr,19)
  378.     nCentury    = floor(nYr/100)+1
  379.     nNoLeap     = floor(3*nCentury/4)-12
  380.     nMoonOrbit  = floor((8*nCentury+5)/25)-5
  381.     nEPact      = mod(11*nGolden+nMoonOrbit-nNoLeap+20,30)
  382.     nEPact      = nEPact+iif(nEPact=24.or.(nEPact=25.and.nGolden>11),1,0)
  383.     dPascMoon   = ctod("03/21/"+str(nYr)+mod(53-nEPact,30))
  384.     dReturn     = dPascMoon+8-dow(dPascMoon)
  385.  
  386. RETURN dReturn
  387. *-- EoF: EasterDay()
  388.  
  389. FUNCTION nDoW
  390. *-------------------------------------------------------------------------------
  391. *-- Programmer..: Jay Parsons (CIS: 70160,340) 
  392. *-- Date........: 04/22/1992
  393. *-- Notes.......: Numeric Day of Week -- returns the numeric value of the
  394. *--               day of week for use by some of the other date functions
  395. *--               below.
  396. *-- Written for.: dBASE IV, 1.1
  397. *-- Rev. History: 02/25/1992 - original function.
  398. *--               04/22/1992 - Jay Parsons - modified example/descriptions,
  399. *--                added ltrim() of argument.
  400. *-- Calls.......: None
  401. *-- Called by...: None
  402. *-- Usage.......: nDoW(<cDay>)
  403. *-- Example.....: nDay = nDoW("Tues")
  404. *-- Returns.....: Numeric dow value of day of week given
  405. *-- Parameters..: cDay  -- Character memvar containing "day" of week ('MONDAY',
  406. *--                        etc ...)
  407. *-------------------------------------------------------------------------------
  408.  
  409.     parameter cDay
  410.     
  411. RETURN at(upper(left(ltrim(cDay),3)),"   SUN MON TUE WED THU FRI SAT")/4
  412. *-- nDoW()
  413.  
  414. FUNCTION FWDoM
  415. *-------------------------------------------------------------------------------
  416. *-- Programmer..: Jay Parsons (CIS: 70160,340) 
  417. *-- Date........: 02/25/1992
  418. *-- Notes.......: First Working Day of the Month -- originally I used Dan
  419. *--               Madoni's stuff from Technotes, but Jay came along and pointed
  420. *--               out an easier way to do this. SO, here we have a shorter,
  421. *--               faster, FWDoM function. This returns the first WORKING
  422. *--               day of the month.
  423. *-- Written for.: dBASE IV, 1.1
  424. *-- Rev. History: 02/25/1992 -- Original Release
  425. *-- Calls.......: None
  426. *-- Called by...: Any
  427. *-- Usage.......: FWDoM(<dDate>)
  428. *-- Example.....: ? CDoW( FWDoM(DATE()) ) (character day of week ...)
  429. *-- Returns.....: dBASE Date
  430. *-- Parameters..: dDate  -- date to work from ...
  431. *-------------------------------------------------------------------------------
  432.  
  433.     parameters dDate
  434.     private dReturn, nDay
  435.     
  436.     dReturn = dDate - day(dDate) + 1
  437.     nDay = DoW(dReturn)
  438.     
  439. RETURN dReturn + iif(nDay=7,2,iif(nDow=1,1,0))
  440. *-- EoF: FWDoM()
  441.  
  442. FUNCTION LWDoM
  443. *-------------------------------------------------------------------------------
  444. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  445. *-- Date........: 02/25/1992
  446. *-- Notes.......: Last Working Day of the Month -- function from Jay (new
  447. *--               version like FWDoM) to return the last working day of the
  448. *--               month. Give a date, the function returns the last WORKING day 
  449. *--               of the month. This has a companion function, giving the 
  450. *--               FIRST working day (see above).
  451. *-- Written for.: dBASE IV, 1.1
  452. *-- Rev. History: 02/25/1992 -- Original Release
  453. *-- Calls.......: LDOM()               Function in DATES.PRG
  454. *-- Called by...: Any
  455. *-- Usage.......: LWDoM(<dDate>)
  456. *-- Example.....: ? LWDoM(DATE())
  457. *-- Returns.....: dBASE Date
  458. *-- Parameters..: dDate  -- date to work from ...
  459. *-------------------------------------------------------------------------------
  460.  
  461.     parameters dDate
  462.     private dReturn, nDay
  463.     
  464.     dReturn = ldom(dDate)
  465.     nDay = DoW(dReturn)
  466.  
  467. RETURN dReturn - iif(nDay=7,1,iif(nDay=1,2,0))
  468. *-- EoF: LWDoM()
  469.  
  470. FUNCTION FDoD
  471. *-------------------------------------------------------------------------------
  472. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  473. *-- Date........: 02/25/1992
  474. *-- Notes.......: First Day of Date. This function works to give the first
  475. *--               date in a given month (using a date) that a specific day
  476. *--               of the week occurs (i.e., first Monday of the month).
  477. *--               It returns a blank date if the day of week doesn't match, 
  478. *--               but is not case sensitive. New, slimmer, sleeker version
  479. *--               by Jay ...
  480. *-- Written for.: dBASE IV, 1.1
  481. *-- Rev. History: 02/25/1992 -- Original Release
  482. *-- Calls.......: NDOW()               Function in DATES.PRG
  483. *-- Called by...: Any
  484. *-- Usage.......: FDoD(<dDate>,"<cDay>")
  485. *-- Example.....: ? FDoD(DATE(),"Tuesday")
  486. *-- Returns.....: dBASE Date
  487. *-- Parameters..: dDate  -- date to work from ...
  488. *--               cDay   -- Day of week to look for ...
  489. *-------------------------------------------------------------------------------
  490.  
  491.     parameters dDate, cDay
  492.     private dReturn, nDay
  493.     
  494.     nDay = nDoW(cDay)
  495.     dReturn = dDate - day(dDate) + 1
  496.     
  497. RETURN dReturn + mod(nDay+7 - DoW(dReturn),7)
  498. *-- EoF: FDoD()
  499.  
  500. FUNCTION LDoD
  501. *-------------------------------------------------------------------------------
  502. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  503. *-- Date........: 02/25/1992
  504. *-- Notes.......: Last Day of Date. This function works to give the last
  505. *--               date in a given month (using a date) that a specific day
  506. *--               of the week occurs (i.e., last Monday of the month).
  507. *--               It returns a blank date if the day of week doesn't match, 
  508. *--               but is not case sensitive. New version as FDoD() ...
  509. *-- Written for.: dBASE IV, 1.1
  510. *-- Rev. History: 02/25/1992 -- Original Release
  511. *-- Calls.......: LDOM()               Function in DATES.PRG
  512. *--               NDOW()               Function in DATES.PRG
  513. *-- Called by...: Any
  514. *-- Usage.......: LDoD(<dDate>,"<cDay>")
  515. *-- Example.....: ? LDoD(DATE(),"Tuesday")
  516. *-- Returns.....: dBASE Date
  517. *-- Parameters..: dDate  -- date to work from ...
  518. *--               cDay   -- Day of week to look for ...
  519. *-------------------------------------------------------------------------------
  520.  
  521.     parameters dDate, cDay
  522.     private dReturn
  523.     
  524.     nDay = nDoW(cDay)
  525.     dReturn = ldom(dDate)
  526.     
  527. RETURN dReturn - mod(dow(dReturn) + 7 - nDay,7)
  528. *-- EoF: LDoD()
  529.  
  530. FUNCTION LDoM
  531. *-------------------------------------------------------------------------------
  532. *-- Programmer..: Ken Chan (HazMatZak)
  533. *-- Date........: 02/26/1992
  534. *-- Notes.......: Last Day of Month -- Zak wrote this one up as a MUCH shorter
  535. *--               and more straightforward version of the one I did. >sigh<.
  536. *--               This function returns the date of the last day of the month.
  537. *-- Written for.: dBASE IV, 1.1
  538. *-- Rev. History: 02/26/1992 -- Original Release
  539. *-- Calls.......: None
  540. *-- Called by...: Any
  541. *-- Usage.......: LDoM(<dDate>)
  542. *-- Example.....: ? LDoM(DATE())
  543. *-- Returns.....: dBASE Date
  544. *-- Parameters..: dDate  -- date to work from ...
  545. *-------------------------------------------------------------------------------
  546.  
  547.     parameter dDate
  548.     private dNxtMonth
  549.     
  550.     dNxtMonth = dDate - day(dDate) + 45 && middle of next month
  551.     
  552. RETURN dNxtMonth - day(dNxtMonth)
  553. *-- EoF: LDoM()
  554.  
  555. FUNCTION NumDoD
  556. *-------------------------------------------------------------------------------
  557. *-- Programmer..: Ken Mayer (CIS: 71333,1033)
  558. *-- Date........: 02/24/1992
  559. *-- Notes.......: This function will return the x daytype of a month.
  560. *--               Example: what if you need the third Monday of the month?
  561. *-                Send to this function a date (any date) of the month,
  562. *--               the number you need (first, second...) and the day you
  563. *--               need. The function is not case specific.
  564. *-- Written for.: dBASE IV, 1.1
  565. *-- Rev. History: 02/24/1992 -- Original Release
  566. *-- Calls.......: FDOD()               Function in DATES.PRG
  567. *--               NDOW()               Function in DATES.PRG
  568. *-- Called by...: Any
  569. *-- Usage.......: NumDoD(<dDate>,<nDay>,<cDay>)
  570. *-- Example.....: ?NumDoD({02/03/92},3,"Monday")
  571. *-- Returns.....: Date
  572. *-- Parameters..: dDate  =  Any date of the month (and year) needed
  573. *--               nDay   =  Number of day you need (i.e., third cDay of month)
  574. *--               cDay   =  Character value of day (Monday, Tuesday, etc.)
  575. *-------------------------------------------------------------------------------
  576.  
  577.     parameter dDate, nDay, cDay
  578.     private dReturn
  579.     
  580.     dReturn = FDoD(dDate,cDay)  && get the first day of this type of the month
  581.     if nDay > 1                 && if it's greater than one, add 7 (1 week) for
  582.                                 && required # ...
  583.         dReturn = dReturn + ((nDay-1)*7)
  584.     endif
  585.     
  586. RETURN dReturn
  587. *-- EoF: NumDoD()
  588.  
  589. FUNCTION WDiF
  590. *-------------------------------------------------------------------------------
  591. *-- Programmer..: Martin Leon (HMAN)
  592. *-- Date........: 12/12/1991
  593. *-- Notes.......: This UDF is designed to return the first Working Day In the
  594. *--               Future of a specific date, based on a # of days. For example,
  595. *--               to return the first working day, 10 days from the current
  596. *--               date, you can pass the parameters of DATE() and 10. If the
  597. *--               date 10 days from today is a working day, that date is
  598. *--               returned, otherwise, the function returns the next closest
  599. *--               working day. You may, if you wish, use a database to
  600. *--               store holidays. If you do, the database must be laid out
  601. *--               with the following structure:
  602. *--                 HOLIDAYS.DBF
  603. *--                 Field name  Field type  MDX?
  604. *--                 HOLIDATE      Date       Y
  605. *--               Once the UDF has been run, the database is left open in 
  606. *--               whatever work area it was opened.  If another database was 
  607. *--               in use at the time of calling the UDF, it becomes the active
  608. *--               database after the UDF is done. The reason for leaving the 
  609. *--               database open is that this speeds up the process when you 
  610. *--               call on the UDF several times in a row.
  611. *--               To ensure that holidays are working properly, there are
  612. *--               3 assumptions made by this function, and all must be true.
  613. *--               These are: 1) WDIF() assumes that your holidays database
  614. *--               has an index tag on the HOLIDATE field, 2) there are no
  615. *--               duplicate entries, and 3) none of the holidays in the data-
  616. *--               base fall on a weekend date. A simple method for insuring
  617. *--               the last is:
  618. *--                 USE Holidays
  619. *--                 DELETE FOR DOW( Holidate ) = 7 .or. DOW( Holidate ) = 1
  620. *--                 PACK
  621. *--               If you do not have a Holidays database, this function will 
  622. *--               work fine ...
  623. *-- Written for.: dBASE IV, 1.1
  624. *-- Rev. History: 12/12/1991 -- Original Release
  625. *-- Calls.......: None
  626. *-- Called by...: Any
  627. *-- Usage.......: WDIF(<dStart>,<nDays>)
  628. *-- Example.....: ?WDiF(date(),10)
  629. *-- Returns.....: dBASE date
  630. *-- Parameters..: dStart  =  Date to start counting from
  631. *--               nDays   =  Number of working days in the future ...
  632. *-------------------------------------------------------------------------------
  633.  
  634.     parameter dStart, nWDays
  635.     private nweeks, n, nXtraDays, nHDays, dReturn, cNear, cAlias, dTemp
  636.     
  637.     store 0 to nweeks, n, nHDays, nXtraDays
  638.     store {} to dReturn, dTemp
  639.     store "" to cNear, cAlias
  640.     cNear = set("NEAR")
  641.     
  642.     if nWDays = 0
  643.        RETURN 0
  644.     endif
  645.     
  646.     if type("dStart") + type("nWDays") # "DN"
  647.        RETURN -1
  648.     endif
  649.     
  650.     *-- Rough guestimate of future date within a week
  651.     nweeks = int( nWDays / 5 )
  652.     dReturn = dStart + (nweeks * 7)
  653.     
  654.     *-- Left over number of days from integer division above
  655.     nXtraDays = mod( nWDays, 5 )
  656.     
  657.     *-- Check to see if Holidays database is already in use.  This is
  658.     *-- done so that we don't have to close and open the database for
  659.     *-- every call to this UDF. The first call opens it and subsequent
  660.     *-- calls select it as needed.
  661.     
  662.     *-- Check all work areas for holidays database, starting with work
  663.     *-- area 10 since this is most likely where it was opened the
  664.     *-- first time.
  665.     n = 10
  666.     do while .not. "HOLIDAYS" $ alias( n )
  667.        n = n - 1
  668.        if n = 0
  669.           exit
  670.        endif
  671.     enddo
  672.     *-- If it is open, store current alias name and select holidays
  673.     *-- database.
  674.     if n # 0
  675.        cAlias = alias()
  676.        select (alias(n))
  677.     else
  678.        *-- If it isn't the currently selected database,
  679.        *-- make sure it exists and use it and select it.
  680.        if file( "HOLIDAYS.DBF" )
  681.           cAlias = alias()
  682.           use Holidays order Holidate in select()
  683.           select Holidays
  684.        endif
  685.     endif
  686.     *-- If it's active now ...
  687.     if alias() = "HOLIDAYS"
  688.        *-- make sure it's in Holidate order, and ...
  689.        if order() # "HOLIDATE"
  690.           set order to Holidate
  691.        endif
  692.        set near on
  693.        *-- count all records in holiday database that fall within the
  694.        *-- range of the starting date and the rough guestimate date.
  695.        seek dStart
  696.        *-- don't count starting day if it's in Holidays database.
  697.        if dStart = Holidate
  698.           skip
  699.        endif
  700.        scan while dReturn >= Holidate 
  701.           nHDays = nHDays + 1
  702.        endscan
  703.        set near off
  704.     endif
  705.     
  706.     *-- Add holidays to "left over" days from original guestimate
  707.     nXtraDays = nXtraDays + nHDays
  708.     
  709.     *-- Add extra days one day at a time to the original guestimate,
  710.     *-- skipping over holidays and weekends.
  711.     
  712.     do while nXtraDays > 0
  713.        dReturn = dReturn + 1
  714.        if alias() = "HOLIDAYS"
  715.           if seek(dReturn)
  716.              loop
  717.           endif
  718.        endif
  719.        if dow( dReturn ) = 7 .or. dow( dReturn ) = 1
  720.           loop
  721.        endif
  722.        nXtraDays = nXtraDays - 1
  723.     enddo
  724.     
  725.     *-- If return date falls on Saturday or Sunday, "re-wind" to Friday.
  726.     dReturn = dReturn - ;
  727.        iif( dow( dReturn ) = 7, 1, iif( dow(dReturn) = 1, 2, 0 ))
  728.     
  729.     *-- If another database was origally in use, make it the active
  730.     *-- database again.
  731.     if "" # cAlias
  732.        select (cAlias)
  733.     endif
  734.     *-- set NEAR back to what it was orginally.
  735.     set near &cNear
  736.  
  737. RETURN dReturn
  738. *-- EoF: WDiF()
  739.  
  740. FUNCTION StoD
  741. *-------------------------------------------------------------------------------
  742. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  743. *-- Date........: 11/10/1991
  744. *-- Notes.......: Convert string YYYYMMDD or YYMMDD to a date regardless of
  745. *--               SET DATE. 
  746. *-- Written for.: dBASE IV, 1.1
  747. *-- Rev. History: 11/10/1991 -- Original Release
  748. *-- Calls.......: None
  749. *-- Called by...: Any
  750. *-- Usage.......: StoD("<cString>")
  751. *-- Example.....: ?StoD("19910101")
  752. *-- Returns.....: Date
  753. *-- Parameters..: <cString> = Date string you wish converted to "normal" dBASE
  754. *--                           date. Must be in either YYYYMMDD or YYMMDD format.
  755. *-------------------------------------------------------------------------------
  756.  
  757.     parameters cString
  758.     private dTest, cMonth, cDay, cYear, dReturn
  759.     
  760.     dTest = ctod("01/02/03")
  761.     if len(cString) < 8
  762.         cString = left(str(year(date()),4),2) + cString
  763.     endif
  764.     cYear  = left(cString, 4)
  765.     cMonth = substr(cString, 5, 2)
  766.     cDay   = right(cString, 2)
  767.     do case
  768.         case month(dTest) = 1
  769.             dReturn = ctod(cMonth + "/" + cDay + "/" + cYear)
  770.         case day(dTest) = 1
  771.             dReturn = ctod(cDay + "/" + cMonth + "/" + cYear)
  772.         otherwise
  773.             dReturn = ctod(cYear + "/" + cMonth + "/" + cDay)
  774.     endcase
  775.  
  776. RETURN dReturn
  777. *-- EoF: StoD()
  778.  
  779. FUNCTION Quarter
  780. *-------------------------------------------------------------------------------
  781. *-- Programmer..: Bowen Moursund (CIS: 76566,1405)
  782. *-- Date........: 02/03/1992
  783. *-- Notes.......: Returns the quarter of the year of a specific date ...
  784. *-- Written for.: dBASE IV, 1.1
  785. *-- Rev. History: 02/03/1992 -- Original Release
  786. *-- Calls.......: None
  787. *-- Called by...: Any
  788. *-- Usage.......: Quarter(<dDate>)
  789. *-- Example.....: ?Quarter({05/25/1992})
  790. *-- Returns.....: Numeric (integer) value from 1 to 4 (or 0 on error ...)
  791. *-- Parameters..: dDate = date to be checked
  792. *-------------------------------------------------------------------------------
  793.  
  794.     Parameter dDate
  795.  
  796. RETURN iif(type("dDate")="D",ceiling(month(dDate)/3),0)
  797. *-- EoF: Quarter()
  798.  
  799. FUNCTION Dat2Jul
  800. *-------------------------------------------------------------------------------
  801. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  802. *-- Date........: 03/01/1992
  803. *-- Notes.......: Converts dBASE date to Julian # of days (from January 1,
  804. *--               4713 B.C.)
  805. *-- Rev. History: 03/01/1992 -- Original Release
  806. *-- Written for.: dBASE IV
  807. *-- Rev. History: None
  808. *-- Calls.......: None
  809. *-- Called by...: Any
  810. *-- Usage.......: Dat2Jul("<dDate>")
  811. *-- Example.....: ?Dat2Jul(date())
  812. *-- Returns.....: Numeric
  813. *-- Parameters..: dDate = Date to convert to Julian ...
  814. *-------------------------------------------------------------------------------
  815.  
  816.     PARAMETERS dDate
  817.     
  818. RETURN 2415386 + dDate - ctod( "01/01/01" )
  819. *-- EoF: Dat2Jul()
  820.  
  821. FUNCTION Jul2Dat
  822. *-------------------------------------------------------------------------------
  823. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  824. *-- Date........: 03/01/1992
  825. *-- Notes.......: Converts Julian # of days to dBASE Date
  826. *-- Rev. History: 03/01/1992 -- Original Release
  827. *-- Written for.: dBASE IV
  828. *-- Rev. History: None
  829. *-- Calls.......: None
  830. *-- Called by...: Any
  831. *-- Usage.......: Jul2Dat(nJulian)
  832. *-- Example.....: ?Jul2Dat(2448691)
  833. *-- Returns.....: Date
  834. *-- Parameters..: nJulian = Julian date to convert to dBase Date
  835. *-------------------------------------------------------------------------------
  836.  
  837.     parameters nJulian
  838.     
  839. RETURN ctod( "01/01/01" ) + (nJulian - 2415386)
  840. *-- EoF: Jul2Dat()
  841.  
  842. FUNCTION DateSet
  843. *-------------------------------------------------------------------------------
  844. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  845. *-- Date........: 03/01/1992
  846. *-- Notes.......: Returns string giving name of current DATE format
  847. *--               This is not needed in Version 1.5, in which set("DATE")
  848. *--               returns the format.  Unlike that function in 1.5, this
  849. *--               one cannot distinguish between date formats set with
  850. *--               different terms that amount to the same thing:
  851. *--                     DMY = BRITISH = FRENCH
  852. *--                     MDY = AMERICAN
  853. *--                     YMD = JAPAN
  854. *--               If your users will be using one of these formats and
  855. *--               are sensitive about the name, substitute the one they
  856. *--               want for the equivalent in this function.
  857. *-- Rev. History: 03/01/1992 -- Original Release
  858. *-- Written for.: dBASE IV, versions below 1.5
  859. *-- Rev. History: None
  860. *-- Calls.......: None
  861. *-- Called by...: Any
  862. *-- Usage.......: DateSet()
  863. *-- Example.....: ?DateSet()
  864. *-- Returns.....: Character
  865. *-- Parameters..: None
  866. *-------------------------------------------------------------------------------
  867.  
  868.     private cCent, cTestdate, cDelimiter
  869.     cCent = set( "CENTURY" )
  870.     set century off
  871.     cTestdate = ctod( "01/02/03" )
  872.     cDelimiter = substr( dtoc( cTestdate ), 3, 1 )
  873.     set century &cCent
  874.     do case
  875.       case month( cTestdate ) = 1
  876.         RETURN iif( cDelimiter = "-", "USA", "MDY" )
  877.       case day( cTestdate ) = 1
  878.         RETURN iif( cDelimiter = "/", "DMY", ;
  879.           iif( cDelimiter = ".", "GERMAN", "ITALIAN" ) )
  880.       otherwise
  881.         RETURN iif( cDelimiter = ".", "ANSI", "YMD" )
  882.     endcase
  883.     
  884. *-- EoF: DateSet()
  885.  
  886. FUNCTION FrstNxtMth
  887. *-------------------------------------------------------------------------------
  888. *-- Programmer..: Todd Barry (TODDBARRY)
  889. *-- Date........: 04/04/1992
  890. *-- Notes.......: Returns first day of next month
  891. *-- Written for.: dBASE IV, 1.1
  892. *-- Rev. History: 04/04/1992 -- Original Release
  893. *--               02/25/1993 -- Shorted by Jay Parsons, based on Zak's LDOM()
  894. *--                 function.
  895. *-- Calls.......: None
  896. *-- Called by...: Any
  897. *-- Usage.......: FrstNxtMth(<dDate>)
  898. *-- Example.....: FrstNxtMth( dDate )
  899. *-- Returns.....: dBASE Date
  900. *-- Parameters..: dDate  -- date to work from ...
  901. *-------------------------------------------------------------------------------
  902.     
  903.     parameters dDate
  904.     private dReturn
  905.     
  906.     dReturn = dDate - day(dDate) + 45
  907.  
  908. RETURN dReturn - day(dReturn) + 1
  909. *-- EoF: FrstNxtMth()
  910.  
  911. FUNCTION FDoM
  912. *-------------------------------------------------------------------------------
  913. *-- Programmer..: Kenneth Chan [ZAK] (CIS: 71542,2712)
  914. *-- Date........: 01/05/1993
  915. *-- Notes.......: First Day of Month 
  916. *-- Written for.: dBASE IV, 1.5
  917. *-- Rev. History: 01/05/1993 -- Original Release
  918. *-- Calls.......: None
  919. *-- Called by...: Any
  920. *-- Usage.......: FDoM(<dArg>)
  921. *-- Example.....: ?FDOM(date())
  922. *-- Returns.....: Date
  923. *-- Parameters..: dArg = a Date argument -- function returns first day of the
  924. *--                      month of this date.
  925. *-------------------------------------------------------------------------------
  926.  
  927.   parameter dArg
  928.  
  929. RETURN dArg - day( dArg ) + 1
  930. *-- EoF: FDoM()
  931.  
  932. FUNCTION FDoY
  933. *-------------------------------------------------------------------------------
  934. *-- Programmer..: Kenneth Chan [ZAK] (CIS: 71542,2712)
  935. *-- Date........: 01/05/1993
  936. *-- Notes.......: Returns January 1 of the year of the date argument passed
  937. *--               to it.
  938. *-- Written for.: dBASE IV, 1.5
  939. *-- Rev. History: 01/05/1993 -- Original Release
  940. *-- Calls.......: None
  941. *-- Called by...: Any
  942. *-- Usage.......: FDoY(<dArg>))
  943. *-- Example.....: FDoY(DATE())
  944. *-- Returns.....: January 1 of the year in dArg
  945. *-- Parameters..: dArg = date data
  946. *-------------------------------------------------------------------------------
  947.  
  948.   parameter dArg
  949.   private dJan
  950.   dJan = dArg - day( dArg ) + 1 - 28 * ( month( dArg ) - 1 )
  951.  
  952. RETURN dJan - day( dJan ) + 1
  953. *-- EoF: FDoY()
  954.  
  955. FUNCTION LDoY
  956. *-------------------------------------------------------------------------------
  957. *-- Programmer..: Kenneth Chan [ZAK] (CIS: 71542,2712)
  958. *-- Date........: 01/05/1993
  959. *-- Notes.......: Returns December 31 of year in date argument passed to 
  960. *--               function.
  961. *-- Written for.: dBASE IV, 1.5
  962. *-- Rev. History: 01/05/1993 -- Original Release
  963. *-- Calls.......: LDoM()               Function in DATES.PRG
  964. *-- Called by...: Any
  965. *-- Usage.......: LDoY(<dArg>)
  966. *-- Example.....: ?LDoY(Date())
  967. *-- Returns.....: Last Day of Year
  968. *-- Parameters..: dArg = Date 
  969. *-------------------------------------------------------------------------------
  970.  
  971.   parameter dArg
  972.   private dDec
  973.   dDec = dArg - day( dArg ) + 28 * ( 13 - month( dArg ))
  974.  
  975. RETURN LDoM( dDec )
  976. *-- EoF: LDoY()
  977.  
  978. FUNCTION QDate
  979. *-------------------------------------------------------------------------------
  980. *-- Programmer..: Kenneth Chan [Zak]  (CIS:71542,2712)
  981. *-- Date........: 01/05/1993
  982. *-- Notes.......: Quicken-style dates
  983. *--               Works best when BELL is OFF and CONFIRM is ON
  984. *--               Works with any SET DATE format
  985. *-- Written for.: dBASE IV, 1.5
  986. *-- Rev. History: 01/05/1993 1.0
  987. *-- Calls.......: FDoM()               Function in DATES.PRG
  988. *--               LDoM()               Function in DATES.PRG
  989. *--               FDoY()               Function in DATES.PRG
  990. *--               LDoY()               Function in DATES.PRG
  991. *--               Strip()              Function in STRINGS.PRG
  992. *-- Called by...: WHEN clause of GET
  993. *-- Usage.......: @ ... GET <dArg> ... WHEN QDate( <dArg> ) ....
  994. *--
  995. *--                 Key         Function
  996. *--                 ---         --------
  997. *--                  T           Today's date
  998. *--                  - or _      Day before
  999. *--                  + or =      Day after
  1000. *--                  M           First day of month  |  Repeated keypress will
  1001. *--                  H           Last day of month   |  give you previous/next
  1002. *--                  Y           First day of year   |  month/year
  1003. *--                  R           Last day of year    |
  1004. *--                  digit       Begin manual date entry
  1005. *--
  1006. *-- Example.....: dFoo = date()
  1007. *--               @ 10,10 get dFoo when QDate( dFoo )
  1008. *-- Returns.....: .T.
  1009. *-- Parameters..: dArg = Date variable/field you're GETting
  1010. *-------------------------------------------------------------------------------
  1011.  
  1012.   parameter dArg
  1013.   private lLoop, nRow, nCol, lConfirmOn, nKey, cLastKey, cSimKey
  1014.   lLoop      = .t.
  1015.   nRow       = row()
  1016.   nCol       = col()
  1017.   lConfirmOn = ( set( "CONFIRM" ) = "ON" )
  1018.   cLastKey   = ""
  1019.   cSimKey    = ""
  1020.  
  1021.   *-- Save screen in case of Esc
  1022.   save screen to sQDate
  1023.  
  1024.   *-- Check for skip flag (used when SET CONFIRM is ON)
  1025.   if type( "x__QDate" ) # "U"
  1026.     release x__QDate
  1027.  
  1028.   else
  1029.     do while lLoop
  1030.       *-- Display current date in special color
  1031.       @ nRow, nCol say dArg color gb+/n        && <-- use your own color ...
  1032.       *-- Move cursor to beginning of date
  1033.       @ nRow, nCol say ""
  1034.       *-- Wait for a keypress
  1035.       nKey = inkey( 0 )
  1036.       *-- Convert to uppercase; ignore keys with negative INKEY() values
  1037.       cKey = upper( chr( max( nKey, 0 )))
  1038.  
  1039.       do case
  1040.         case cKey = "T"                 && Today
  1041.           dArg = date()
  1042.         case cKey = "-" .or. cKey = "_" && The day before
  1043.           dArg = dArg - 1
  1044.         case cKey = "+" .or. cKey = "=" && The day after
  1045.           dArg = dArg + 1
  1046.         case cKey = "M"                 && First day of the month
  1047.           dArg = FDoM( iif( cLastKey = "M", dArg - 1, dArg))
  1048.         case cKey = "H"                 && Last day of the month
  1049.           dArg = LDoM( iif( cLastKey = "H", dArg + 1, dArg))
  1050.         case cKey = "Y"                 && First day of the year
  1051.           dArg = FDoY( iif( cLastKey = "Y", dArg - 1, dArg))
  1052.         case cKey = "R"                 && Last day of the year
  1053.           dArg = LDoY( iif( cLastKey = "R", dArg + 1, dArg))
  1054.         case cKey $ "0123456789"        && Digit -- manual date entry
  1055.           lLoop = .f.
  1056.           *-- Clear entry and start at beginning
  1057.           keyboard chr( 25 ) + chr( 26 ) + cKey
  1058.         case nKey >= 32 .and. nKey < 127 .or. nKey > 127
  1059.           *-- Ignore invalid keys, like letters and symbols
  1060.         case nKey = 27 .or. nKey = 17   && Esc or Ctrl-Q
  1061.           lLoop = .f.
  1062.           *-- Restore screen and quit
  1063.           restore screen from sQDate
  1064.           keyboard cKey
  1065.         otherwise
  1066.           lLoop = .f.
  1067.           *-- Figure out how to simulate last keypress
  1068.           *-- If SET CONFIRM is OFF
  1069.           if .not. lConfirmOn
  1070.             *-- Go back up to date field
  1071.             cSimKey = "{UP}"              && Up arrow
  1072.             *-- Create flag variable to skip routine
  1073.             public x__QDate
  1074.           endif
  1075.           cSimKey = cSimKey + "{HOME}"
  1076.           *-- Recreate keypress
  1077.           do case
  1078.             case nKey = -400
  1079.               cSimKey = cSimKey + "{BACKTAB}"
  1080.             otherwise
  1081.               cSimKey = cSimKey + cKey
  1082.           endcase
  1083.           *-- Clear entry and "type in" date without separators
  1084.           *-- And simulate last keypress
  1085.           keyboard "{HOME}{CTRL-Y}" + ;
  1086.                    Strip( dtoc( dArg ), left( ltrim( dtoc( {} )), 1)) + cSimKey
  1087.       endcase
  1088.       *-- Save key just pressed
  1089.       cLastKey = cKey
  1090.  
  1091.     enddo
  1092.  
  1093.   endif
  1094.  
  1095.   *-- release the screen from memory before returning
  1096.   release screen sQDate
  1097.  
  1098. RETURN .t.
  1099. *-- EoF: QDate()
  1100.  
  1101. *-------------------------------------------------------------------------------
  1102. *-- For more details on the Hebrew Date routines, see the file attached
  1103. *-- called SHANA.TXT, written by Jay Parsons to help explain things.
  1104. *-------------------------------------------------------------------------------
  1105.  
  1106. FUNCTION Hebrewdate
  1107. *-------------------------------------------------------------------------------
  1108. *-- Programmer..: Jay Parsons (Compuserve 70160,340)
  1109. *-- Date........: 03/27/1993
  1110. *-- Notes.......: Converts a date to corresponding date on the Hebrew
  1111. *--               calendar.  The date returned is the Hebrew date that
  1112. *--               matches the daylight hours of the given civil date;
  1113. *--               the Hebrew date actually starts the evening before.
  1114. *-- Written for.: dBASE IV, 2.0
  1115. *-- Rev. History: 03/27/1993 -- Original
  1116. *-- Calls.......: Dat2Heb()                      function in DATES.PRG
  1117. *--               IsLeapH()                      function in DATES.PRG
  1118. *-- Called by...: Any
  1119. *-- Usage.......: Hebrewdate( <dDate> )
  1120. *-- Example.....: ? Hebrewdate( {03/27/93} )
  1121. *-- Returns.....: a character string giving the month, day and year of
  1122. *--               the date, such as "Nisan 5, 5753"
  1123. *-- Parameters..: dDate      = a dBASE date
  1124. *-------------------------------------------------------------------------------
  1125.         parameters dDate
  1126.         private cDate, cMonths, nMo, cMo, nDay, cDay, nYear
  1127.         * ruler -> 012345678901234567890123456789012345678901
  1128.         cMonths = "Tishri HeshvanKislev Tebeth Shebat Adar   " + ;
  1129.                   "Nisan  Iyar   Sivan  Tammuz Ab     Ellul  "
  1130.         cDate = Dat2Heb( dDate )
  1131.         nYear = val( right( cDate, 4 ) )
  1132.         nMo = val( left( cDate, 2 ) )
  1133.         nDay = val( substr( cDate, 4, 2 ) )
  1134.         do case
  1135.           case nMo < 6 .or. .not. IsLeapH( nYear )
  1136.             cMo = trim( substr( cMonths, 7 * ( nMo - 1 ) + 1, 7 ) )
  1137.           case nMo > 7
  1138.             cMo = trim( substr( cMonths, 7 * ( nMo - 2 ) + 1, 7 ) )
  1139.           otherwise
  1140.             cMo = iif( nMo = 6, "First ", "Second " ) + "Adar"
  1141.         endcase
  1142.  
  1143. RETURN cMo + " " + ltrim( str( nDay, 2 ) ) + ", " + right( cDate, 4 )
  1144. *-- EoF: HebrewDate()
  1145.  
  1146. FUNCTION Civildate
  1147. *-------------------------------------------------------------------------------
  1148. *-- Programmer..: Jay Parsons (Compuserve 70160,340)
  1149. *-- Date........: 03/27/1993
  1150. *-- Notes.......: Converts a Hebrew calendar date to corresponding date
  1151. *--               on the civil calendar.  The date returned is the civil
  1152. *--               date that matches the daylight hours of the given Hebrew
  1153. *--               date; the Hebrew day actually starts the evening before.
  1154. *--                     Supplying the function with a nonexistent 30th day of
  1155. *--               Heshvan or Kishlev is fairly harmless; it will return the
  1156. *--               civil date of the first of the following month, the
  1157. *--               correct date to celebrate a birthday falling on the date
  1158. *--               that does not exist in the given year.  This is **NOT**
  1159. *--               sufficient to avoid problems with Adar, or with Yahrzeit
  1160. *--               for deaths occurring on Heshvan 30 or Kishlev 30; users
  1161. *--               are cautioned against finding anniversaries in those cases
  1162. *--               by supplying the Hebrew month and date of the event and
  1163. *--               a different Hebrew year as parameters to this function.
  1164. *--                      In general, reconverting the civil date returned
  1165. *--               to a Hebrew date and comparing it to the original Hebrew
  1166. *--               date furnished to this function will disclose any possible
  1167. *--               problems, as the two Hebrew dates will not match.
  1168. *-- Written for.: dBASE IV, 2.0
  1169. *-- Rev. History: 03/27/1993 -- Original
  1170. *-- Calls.......: Kebiah()                      function in DATES.PRG
  1171. *--               Roshashana()                  function in DATES.PRG
  1172. *-- Called by...: Any
  1173. *-- Usage.......: Civildate(<cDate> )
  1174. *-- Example.....: ? Civildate( "05/07/5753" )
  1175. *-- Returns.....: dBase date, the corresponding civil date.
  1176. *-- Parameters..: cDate      = character string holding month, day and year
  1177. *--                            of Hebrew date, MM/DD/YYYY.  Month must be
  1178. *--                            in range 1-13 and must correspond to month
  1179. *--                            order in the particular year--that is, "12"
  1180. *--                            signifies Ab in a leap year but Ellul in a
  1181. *--                            common year.
  1182. *-------------------------------------------------------------------------------
  1183.         parameters cDate
  1184.         private nMo, nDay, nYear, dDate, cKebiah, aDays
  1185.         nYear = val( right( cDate, 4 ) )
  1186.         nMo = val( left( cDate, 2 ) )
  1187.         nDay = val( substr( cDate, 4, 2 ) )
  1188.         dDate = Roshashana( nYear ) - 1
  1189.         cKebiah = Kebiah( dDate + 1, Roshashana( nYear + 1 ) )
  1190.         declare aDays[ 13 ]
  1191.         aDays[ 1 ] = 30
  1192.         aDays[ 2 ] = iif( cKebiah $ "EFGLMN", 30, 29 )
  1193.         aDays[ 3 ] = iif( cKebiah $ "ABHIJ", 29, 30 )
  1194.         aDays[ 4 ] = 29
  1195.         aDays[ 5 ] = 30
  1196.         if cKebiah > "G"
  1197.           aDays[ 6 ] = 30
  1198.           aDays[ 7 ] = 29
  1199.           nX = 7
  1200.         else
  1201.           aDays[ 6 ] = 29
  1202.           nX = 6
  1203.         endif
  1204.         nY = 1
  1205.         do while nY < 7
  1206.           aDays[ nX + nY ] = 29 + mod( nY, 2 )
  1207.           nY = nY + 1
  1208.         enddo
  1209.         nX = 1
  1210.         do while nX < nMo
  1211.           dDate = dDate + aDays[ nX ]
  1212.           nX = nX + 1
  1213.         enddo
  1214.  
  1215. RETURN dDate + nDay
  1216. *-- EoF: Civildate()
  1217.  
  1218. FUNCTION Dat2Heb
  1219. *-------------------------------------------------------------------------------
  1220. *-- Programmer..: Jay Parsons (Compuserve 70160,340)
  1221. *-- Date........: 03/27/1993
  1222. *-- Notes.......: Converts a date to corresponding date on the Hebrew
  1223. *--               calendar.  The date returned is the Hebrew date that
  1224. *--               matches the daylight hours of the given civil date;
  1225. *--               the Hebrew date actually starts the evening before.
  1226. *-- Written for.: dBASE IV, 2.0
  1227. *-- Rev. History: 03/27/1993
  1228. *-- Calls.......: Kebiah()                      function in DATES.PRG
  1229. *--               Roshashana()                  function in DATES.PRG
  1230. *-- Called by...: Any
  1231. *-- Usage.......: Dat2Heb( <dDate> )
  1232. *-- Example.....: ? Dat2Heb( {03/27/93} )
  1233. *-- Returns.....: a character string giving the month, day and year of
  1234. *--               the date in numerals, such as "07/05/5753"
  1235. *-- Parameters..: dDate      = a dBASE civil date to convert
  1236. *-------------------------------------------------------------------------------
  1237.         parameters dDate
  1238.         private nYear, dFirst, dSecond, cKebiah, aDays, nX, nY, nDay
  1239.         nYear = year( dDate ) + 3761
  1240.         dFirst = Roshashana( nYear )
  1241.         if dFirst > dDate
  1242.           nYear = nYear - 1
  1243.           dSecond = dFirst
  1244.           dFirst = Roshashana( nYear )
  1245.         else
  1246.           dSecond = Roshashana( nYear + 1 )
  1247.         endif
  1248.         nDay = 1 + dDate - dFirst
  1249.         cKebiah = Kebiah( dFirst, dSecond )
  1250.         declare aDays[ 13 ]
  1251.         aDays[ 1 ] = 30
  1252.         aDays[ 2 ] = iif( cKebiah $ "EFGLMN", 30, 29 )
  1253.         aDays[ 3 ] = iif( cKebiah $ "ABHIJ", 29, 30 )
  1254.         aDays[ 4 ] = 29
  1255.         aDays[ 5 ] = 30
  1256.         aDays[ 6 ] = iif( cKebiah > "G", 30, 29 )
  1257.         if cKebiah > "G"
  1258.           aDays[ 7 ] = 29
  1259.           nX = 7
  1260.         else
  1261.           nX = 6
  1262.         endif
  1263.         nY = 1
  1264.         do while nY < 7
  1265.           aDays[ nX + nY ] = 29 + mod( nY, 2 )
  1266.           nY = nY + 1
  1267.         enddo
  1268.         nX = 1
  1269.         do while nDay > aDays[ nX ]
  1270.           nDay = nDay - aDays[ nX ]
  1271.           nX = nX + 1
  1272.         enddo
  1273.  
  1274. RETURN right( str( nX + 100, 3 ), 2 ) + "/" + right( str( nDay + 100, 3 ), 2 ) ;
  1275.          + "/" + str( nYear, 4 )
  1276. *-- EoF: Dat2Heb()
  1277.  
  1278. FUNCTION Kebiah
  1279. *-------------------------------------------------------------------------------
  1280. *-- Programmer..: Jay Parsons (Compuserve 70160,340)
  1281. *-- Date........: 03/26/1993
  1282. *-- Notes.......: Kebiah of a year, using Arthur Spier's notation.
  1283. *--                     This tells whether the year in the Hebrew calendar is
  1284. *--               defective, regular or excessive and whether or not a
  1285. *--               leap year.  In order to limit the recalculations of Rosh
  1286. *--               Hashanah in date conversions that would be needed if this
  1287. *--               function were called with the year only, it requires the
  1288. *--               civil dates of the two Rosh Hashanahs at start and end as
  1289. *--               parameters.
  1290. *--                     Error checking is limited to determining whether the
  1291. *--               days of the week of the two dates given and number of
  1292. *--               days between them are possible; no check is made that
  1293. *--               either is the correct date of Rosh Hashanah.
  1294. *-- Written for.: dBASE IV, 2.0
  1295. *-- Rev. History: 03/26/1993 -- Original
  1296. *-- Calls.......: None
  1297. *-- Called by...: Any
  1298. *-- Usage.......: Kebiah(<dRosh1>,dRosh2>)
  1299. *-- Example.....: c = Kebiah( {09/16/1993},{09/06/1994} )
  1300. *-- Returns.....: a letter from A through N, signifying as follows:
  1301. *--                     A - G common year of 12 months
  1302. *--                     H - N leap year of 13 months
  1303. *--                   First day of      length and type        First day of
  1304. *--                   Rosh Hashanah        of year              Passover
  1305. *--                A     Monday        353 days, defective       Tuesday
  1306. *--                B     Sabbath       353 days, defective       Sunday
  1307. *--                C     Tuesday       354 days, regular         Thursday
  1308. *--                D     Thursday      354 days, regular         Sabbath
  1309. *--                E     Monday        355 days, excessive       Thursday
  1310. *--                F     Thursday      355 days, excessive       Sunday
  1311. *--                G     Sabbath       355 days, excessive       Tuesday
  1312. *--                H     Monday        383 days, defective       Thursday
  1313. *--                I     Thursday      383 days, defective       Sunday
  1314. *--                J     Sabbath       383 days, defective       Tuesday
  1315. *--                K     Tuesday       384 days, regular         Sabbath
  1316. *--                L     Monday        385 days, excessive       Sabbath
  1317. *--                M     Thursday      385 days, excessive       Tuesday
  1318. *--                N     Sabbath       385 days, excessive       Thursday
  1319. *--                or "" signifying error in dates passed to function.
  1320. *-- Parameters..: dRosh1      = civil date of Rosh Hashanah starting the year
  1321. *--               dRosh2      = civil date of Rosh Hashanah starting the
  1322. *--                               following year
  1323. *-------------------------------------------------------------------------------
  1324.         parameters dRosh1, dRosh2
  1325.         private dR1, dR2, nDays, nDow, cRet
  1326.         dR1 = min( dRosh1, dRosh2 )
  1327.         dR2 = max( dRosh1, dRosh2 )
  1328.         nDays = dR2 - dR1
  1329.         nDow = dow( dR2 )
  1330.         if nDow = 1 .or. nDow = 4 .or. nDow = 6  && if dR2 is Sun, Wed or Fri
  1331.           RETURN ""
  1332.         endif
  1333.         cRet = space( 7 )     && will return "" if too few or too many days
  1334.         do case
  1335.           * Days    SMTWHFS   && if the portion of a cRet string below a day
  1336.           * Dows    1234567   && of the week is blank, can't be Rosh Hashanah
  1337.           case nDays = 353
  1338.             cRet = " A    B"
  1339.           case nDays = 354
  1340.             cRet = "  C D  "
  1341.           case nDays = 355
  1342.             cRet = " E  F G"
  1343.           case nDays = 383
  1344.             cRet = " H  I J"
  1345.           case nDays = 384
  1346.             cRet = "  K    "
  1347.           case nDays = 385
  1348.             cRet = " L  M N"
  1349.         endcase
  1350.  
  1351. RETURN trim( substr( cRet, dow( dR1 ), 1 ) )
  1352. *-- EoF: Kebiah()
  1353.  
  1354. FUNCTION Roshashana
  1355. *-------------------------------------------------------------------------------
  1356. *-- Programmer..: Jay Parsons (Compuserve 70160,340)
  1357. *-- Date........: 03/26/1993
  1358. *-- Notes.......: Returns date of Rosh Hashanah of the given Hebrew year.
  1359. *--               To find date when Rosh Hashanah occurs in a C.E. year,
  1360. *--               add 3761 to the C.E. Year.  This formidable-looking
  1361. *--               procedure is actually a straightforward matter of using the
  1362. *--               date and time of one Molad Tishri, the moment of new moon
  1363. *--               starting a year, and advancing or setting back that date
  1364. *--               and time by the number of days, hours and chalokim in each
  1365. *--               period of 19 years, then by the number in each month within
  1366. *--               the balance of the years.  Since we are concerned only with
  1367. *--               the molads, we need not worry about the number of days in
  1368. *--               the calendar months, but only with the lunar period of 29
  1369. *--               days, 12 hours and 793 chalokim and the number of months,
  1370. *--               giving effect to leap years.
  1371. *--                     A chelek, plural chalokim, is 1/1080 of an hour, or
  1372. *--               3 1/3 seconds, and is traditionally used for these
  1373. *--               calculations, in part because it avoids the need to deal
  1374. *--               with fractions.
  1375. *--                     Finally, having determined the civil date of the Molad
  1376. *--               Tishri of the proper year and the hour and chalokim within
  1377. *--               the date, we call a separate function to determine the
  1378. *--               applicability of the dechiyoth or postponements that may
  1379. *--               cause Rosh Hashanah to be pushed to a later date.
  1380. *-- Written for.: dBASE IV, 2.0
  1381. *-- Rev. History: 03/26/1993
  1382. *-- Calls.......: NormalH               procedure in DATES.PRG
  1383. *--               Dechiyoth             function in DATES.PRG
  1384. *-- Called by...: Any
  1385. *-- Usage.......: Roshashana( <nYear> )
  1386. *-- Example.....: Roshashana( 1993 + 3761 )
  1387. *-- Returns.....: date       = civil date of Rosh Hashanah in the given year
  1388. *-- Parameters..: nYear      = number of year in the Hebrew calendar
  1389. *-------------------------------------------------------------------------------
  1390.         parameters nYear
  1391.         private dMoldate, nMolhr, nMolch, nYrs, nMoons
  1392.         * we use the Molad of Tishri 5739, October 2, 1978, as the base date
  1393.         * for no particular reason except it started the most recent cycle.
  1394.         dMoldate  = { 10/02/1978 } && The Hebrew date started 6 p.m. Oct. 1.
  1395.         nMolhr    = 11             && The molad fell 11 hours and 614 chalokim
  1396.         nMolch    = 614            && later into the day.
  1397.         nYrs      = nYear - 5739   && years of difference to adjust.
  1398.         * adjust for each full 19-year cycle ( machzor koton )
  1399.         * if adjusting backward, go to beginning of the cycle in which is
  1400.         * the specified year
  1401.         nCycles   = floor( nYrs / 19 )
  1402.         dMoldate  = dMoldate + 6939 * nCycles
  1403.         nMolhr    = nMolhr + 16 * nCycles
  1404.         nMolch    = nMolch + 595 * nCycles
  1405.         * adjust for leftover months within the cycle; the formula was
  1406.         * hacked to return the correct number of months for any number
  1407.         * of years from 0 through 19 at the beginning of a 19-year cycle.
  1408.         nYrs      = nYrs - 19 * nCycles
  1409.         nMoons    = int( .01 + nYrs * 12.374 )
  1410.         dMoldate  = dMoldate +  29 * nMoons      && length of a lunar month,
  1411.         nMolhr    = nMolhr   +  12 * nMoons      && 29 days, 12 hours and
  1412.         nMolch    = nMolch   + 793 * nMoons      && 793 chalokim
  1413.         do NormalH with dMoldate, nMolhr, nMolch
  1414.  
  1415. RETURN dMoldate + Dechiyoth( dMolDate, nMolhr, nMolch )
  1416. *-- EoF: Roshashana()
  1417.  
  1418. FUNCTION Dechiyoth
  1419. *-------------------------------------------------------------------------------
  1420. *-- Programmer..: Jay Parsons (Compuserve 70160,340)
  1421. *-- Date........: 03/26/1993
  1422. *-- Notes.......: Adjusts date of Rosh Hashanah for the four dechiyoth
  1423. *--               ( postponements ) required to regularize the calendar and
  1424. *--               prevent either two days in a row of Sabbath at Yom Kippur
  1425. *--               or Hoshanah Rabbah being on the Sabbath.
  1426. *--                     Days, hours and chalokim  are measured from 6 p.m.
  1427. *--               Friday evening, considered the beginning of the Sabbath for
  1428. *--               calendar purposes.
  1429. *-- Written for.: dBASE IV, 2.0
  1430. *-- Rev. History: 03/26/1993
  1431. *-- Calls.......: IsLeapH                       function in DATES.PRG
  1432. *-- Called by...: Any
  1433. *-- Usage.......: Dechiyoth( <dDate>, <nHrs>, <nChalokim> )
  1434. *-- Example.....: nDay = Dechiyoth( {10/02/1978}, 11, 614 )
  1435. *-- Returns.....: date       = civil date of Rosh Hashanah
  1436. *-- Parameters..: dDate      = civil date of Molad Tishri
  1437. *--               nHrs       = Hebrew hour of Molad Tishri ( past 6. p.m. )
  1438. *--               nChalokim  = chalokim past the hour of Molad Tishri
  1439. *-------------------------------------------------------------------------------
  1440.         parameters dDate, nHrs, nChalokim
  1441.         private nMoldow, nFirst, nNidcheh
  1442.         nMoldow = mod( dow( dDate ), 7 )
  1443.         nNidcheh = 0
  1444.         nFirst = nMoldow
  1445.         * 1) if Molad Tishri is after noon, new moon could not be seen anywhere
  1446.         * that day, so Rosh Hashanah is nidcheh ( pushed off ) to next day
  1447.         if nHrs * 1080 + nChalokim > 18 * 1080
  1448.           nNidcheh = 1
  1449.           nFirst = nFirst + 1
  1450.         endif
  1451.         * 2) if Rosh Hashanah would be Sunday, Wednesday or Friday, it is
  1452.         * nidcheh ( again if dechiyah 1 applied ) so that Yom Kippur will not
  1453.         * fall on Friday or Sunday, nor Hoshanah Rabbah on the Sabbath.
  1454.         if nFirst = 1 .or. nFirst = 4 .or. nFirst = 6
  1455.           nNidcheh = nNidcheh + 1
  1456.         endif
  1457.         * 3) if Molad Tishri in a common year is Tuesday and the next
  1458.         * Molad Tishri would be after noon of the Sabbath, this Rosh Hashanah
  1459.         * is nidcheh twice so the next Rosh Hashanah will not have to be--
  1460.         * the result would be that this year would have 356 days, too many.
  1461.         if .not. IsLeapH( year( dDate ) + 3761 ) .and. nMoldow  = 3 ;
  1462.            .and. 1080 * nHrs + nChalokim > 9 * 1080 + 204   && 9hrs 204
  1463.           nNidcheh = 2
  1464.         endif
  1465.         * 4) if Molad Tishri in a common year following a leap year occurs
  1466.         * Monday morning so late that the preceding leap year must have
  1467.         * started on Thursday, this Rosh Hashanah is nidcheh so the preceding
  1468.         * leap year will not be left with 382 days, too few.
  1469.         if IsLeapH( year( dDate ) + 3760 ) .and. nMoldow = 2 ;
  1470.            .and. 1080 * nHrs + nChalokim > 15 * 1080 + 589  && 15 hrs 589
  1471.           nNidcheh = 1
  1472.         endif
  1473.  
  1474. RETURN nNidcheh
  1475. *-- EoF: Dechiyoth()
  1476.  
  1477. FUNCTION IsLeapH
  1478. *-------------------------------------------------------------------------------
  1479. *-- Programmer..: Jay Parsons (Compuserve 70160,340)
  1480. *-- Date........: 03/27/1993
  1481. *-- Notes.......: Returns .T. or .F. whether a Hebrew year is a leap year.
  1482. *--               The formula is a hack; it returns .T. when the position of
  1483. *--               the year in the cycle is 3, 6, 8, 11, 14, 17 or 19 ( the
  1484. *--               last, because its modulus 19 is 0. )
  1485. *-- Written for.: dBASE IV, 2.0
  1486. *-- Rev. History: 03/27/1993 -- Original
  1487. *-- Calls.......: None
  1488. *-- Called by...: Any
  1489. *-- Usage.......: IsLeapH( <nYear> )
  1490. *-- Example.....: ? IsLeapH( 1993 + 3761 )
  1491. *-- Returns.....: logical    = true if the year is a leap year, or false
  1492. *-- Parameters..: nYear      = number of the year on the Hebrew calendar
  1493. *-------------------------------------------------------------------------------
  1494.         parameters nYear
  1495.         private nY
  1496.         nY = mod( nYear, 19 )
  1497.  
  1498. RETURN mod( nY + int( ( nY + 3 ) / 11 ), 3 ) = 0
  1499. *-- EoF: IsLeapH()
  1500.  
  1501. PROCEDURE NormalH
  1502. *-------------------------------------------------------------------------------
  1503. *-- Programmer..: Jay Parsons (Compuserve 70160,340)
  1504. *-- Date........: 03/26/1993
  1505. *-- Notes.......: Normalize date and numbers of hours and chalokim
  1506. *-- Written for.: dBASE IV, 2.0
  1507. *-- Rev. History: 03/26/1993 -- Original
  1508. *-- Calls.......: None
  1509. *-- Called by...: Any
  1510. *-- Usage.......: DO NormalH with <dDate>, <nHrs>, <nChalokim>
  1511. *-- Example.....: DO Normalh with { 03/13/1993}, 39, 1452
  1512. *-- Parameters..: dDate         = a dBASE civil date
  1513. *--               nHrs          = number of hours
  1514. *--               nChalokim     = number of chalokim
  1515. *-- Side Effects: This procedure changes its parameters.
  1516. *-------------------------------------------------------------------------------
  1517.         parameters dDate, nHrs, nChalokim
  1518.         nHrs       = nHrs + floor( nChalokim / 1080 )
  1519.         nChalokim  = mod( nChalokim, 1080 )
  1520.         dDate      = dDate + floor( nHrs / 24 )
  1521.         nHrs       = mod( nHrs, 24 )
  1522.  
  1523. RETURN
  1524. *-- EoP: NormalH
  1525.  
  1526. FUNCTION MDY_UDF
  1527. *-------------------------------------------------------------------------------
  1528. *-- Programmer..: Angus Scott-Fleming (CIS: 75500,3223)
  1529. *-- Date........: 11/25/1992
  1530. *-- Note........: Print date nicely, regardless of SET CENTURY setting
  1531. *--             : MDY({01/01/80})     prints as "January 01, 80"
  1532. *--             : MDY_UDF({01/01/80}) prints as "January 1, 1980"
  1533. *-- Written for.: dBASE IV 1.5+
  1534. *-- Rev. History: 11/25/1992 -- Original
  1535. *-- Calls.......: None
  1536. *-- Called by...: Any
  1537. *-- Usage.......: MDY_UDF(<dDate>)
  1538. *-- Example.....: ? MDY_Udf(ctod("01/01/92"))
  1539. *-- Returns.....: character representation of current date
  1540. *-- Parameters..: dDate = date to modify
  1541. *-------------------------------------------------------------------------------
  1542.     parameters dDate
  1543.     if .not. IsBlank(dDate)
  1544.       return cmonth(dDate)+" "+iif(day(dDate)<10,str(day(dDate),1),;
  1545.         str(day(dDate),2))+", "+str(year(dDate),4)
  1546.     else
  1547.       return ""
  1548.     endif
  1549. *-- EoF: MDY_UDF()
  1550.  
  1551. *--------------------------------------------------------------------------
  1552. *-- Strip() is here from STRINGS.PRG to make life a bit easier ...
  1553. *--------------------------------------------------------------------------
  1554.  
  1555. FUNCTION Strip
  1556. *-------------------------------------------------------------------------------
  1557. *-- Programmer..: Kenneth Chan [ZAK] (CIS: 71542,2712)
  1558. *-- Date........: 01/05/1993
  1559. *-- Notes.......: Strips out specified character(s) from a string
  1560. *-- Written for.: dBASE IV, 1.5
  1561. *-- Rev. History: 01/05/1993 -- Original Release
  1562. *-- Calls.......: None
  1563. *-- Called by...: Any
  1564. *-- Usage.......: Strip(<cVar>,<cArg>)
  1565. *-- Example.....: ?strip(dtoc(date(),"/")
  1566. *-- Returns.....: Character
  1567. *-- Parameters..: cVar = variable/field to remove character(s) from
  1568. *--               cArg = item to remove from cVar
  1569. *-------------------------------------------------------------------------------
  1570.  
  1571.   parameter cVar, cArg
  1572.   do while cArg $ cVar
  1573.     cVar = stuff( cVar, at( cArg, cVar ), 1, "" )
  1574.   enddo
  1575.  
  1576. RETURN cVar
  1577. *-- EoF: Strip()
  1578.  
  1579. *-------------------------------------------------------------------------------
  1580. *-- EoP: DATES.PRG
  1581. *-------------------------------------------------------------------------------
  1582.